PC-X 1997 October/pcx14_9710.iso/swag/delphi.swg/0041_TSizer unit for DELPHI forms.pas

Pascal/Delphi Source File | 1995-11-22 | 7.1 KB | 248 lines

unit Sizer;

interface

uses
    Messages, WinTypes, Classes, WinProcs, Controls, Forms, SysUtils;

type ENonWindowOwner=class(Exception);

{------------------------------------------------------------------}
{--- Message Grabber ----------------------------------------------}
{------------------------------------------------------------------}
{Provides a component basis from which to trap messages sent to the form.
To override specific messages, descend from TMessageGrabber and either
add a message response method (such as WMGetMinMaxInfo), or override
the virtual method WndProc}

type TMessageGrabber = class(TComponent)
        private
            OwnerWndProc:TFarProc;
            MyWndProc:TFarProc;
            OwnerProcGrabbedQ:Boolean;
        protected
            procedure WndProc(var Msg:TMessage); virtual;
            procedure DefaultHandler(var Msg); override;
            procedure WMDestroy(var Msg:TWMDestroy); message WM_Destroy;
        public
            constructor Create(AOwner:TComponent); override;
            destructor  Destroy; override;
        end;

{------------------------------------------------------------------}
{--- Sizer --------------------------------------------------------}
{------------------------------------------------------------------}
{An example TMessageGrabber.
Traps WMGetMinMaxInfo to give a specified maximum dimensions.
Also resizes itself to give a specified Client area, regardless of
how many lines the menu bar wraps onto}

type
    TSizer = class(TMessageGrabber)
    private
        Resizing,SizeSet:boolean;
        DesiredWidth,DesiredHeight:longint;
        DeskSize:TPoint;
        MinW,MinH,FullW,FullH:longint;
        procedure SetDesiredWidth(NewWidth:longint);
        procedure SetDesiredHeight(NewHeight:longint);
    protected
        procedure WMGetMinMaxInfo(var Msg:TMessage); message WM_GetMinMaxInfo;
    public
        constructor Create(AOwner:TComponent); override;
        procedure Resize;
        procedure SetSurfaceBounds(Width,Height:longint);
    published
        property SurfaceWidth:longint read DesiredWidth write SetDesiredWidth;
        property SurfaceHeight:longint read DesiredHeight write SetDesiredHeight;
    end;

procedure Register;

implementation

{------------------------------------------------------------------}
{--- Message Grabber ----------------------------------------------}
{------------------------------------------------------------------}

{Create:
Override the WndProc of the owner window.
Note that it will be a very bad idea to have several MessageGrabber
components active at the same time, unless they are added and removed
carefully in order}

constructor TMessageGrabber.Create(AOwner:TComponent);
begin
if not(AOwner is TWinControl) then
    raise ENonWindowOwner.Create('Owner must be a windowed control');
inherited Create(AOwner);
OwnerWndProc:=TFarProc(GetWindowLong((Owner as TWinControl).Handle,gwl_WndProc));
MyWndProc:=MakeObjectInstance(WndProc);
SetWindowLong((Owner as TWinControl).Handle,gwl_WndProc,LongInt(MyWndProc));
OwnerProcGrabbedQ:=True;
end;

{Destroy:
Removes the overriding window handler}

destructor TMessageGrabber.Destroy;
begin
if OwnerProcGrabbedQ then
    SetWindowLong((Owner as TWinControl).Handle,gwl_WndProc,LongInt(OwnerWndProc));
FreeObjectInstance(MyWndProc);
inherited Destroy;
end;

{WMDestroy:
If WM_Destroy is sent to the owner, then when we get around to calling
the Destroy method here, Owner will no longer be valid. So, there are
two cases: Destroy is called without WMDestroy (ie component is removed
at design-time) and WMDestroy is called first (ie owner is about to be
destroyed)}

procedure TMessageGrabber.WMDestroy(var Msg:TWMDestroy);
begin
SetWindowLong((Owner as TWinControl).Handle,gwl_WndProc,LongInt(OwnerWndProc));
OwnerProcGrabbedQ:=False;
end;

{WndProc:
For windowed controls, standard message handling is:
the message is sent to WndProc, which calls Dispatch.
Only windows controls have a WndProc. But Dispatch is a method
of TObject, used for dispatching all message-based methods, not
just Windows ones. This WndProc mimics that of a windowed control}

procedure TMessageGrabber.WndProc(var Msg:TMessage);
begin
Dispatch(Msg);
end;

{DefaultHandler:
The Dispatch method will attempt to dispatch the method, and failing
will call DefaultHandler. If a message-response method calls
its inherited method, where the inherited method is undefined, the
message is also sent to the DefaultHandler.
For a TMessageGrabber, DefaultHandler should pass any unhandled
messages back to the owner}

procedure TMessageGrabber.DefaultHandler(var Msg);
begin
with TMessage(Msg) do
    Result:=CallWindowProc(OwnerWndProc,(Owner as TWinControl).Handle,Msg,wParam,lParam);
end;

{------------------------------------------------------------------}
{--- Sizer --------------------------------------------------------}
{------------------------------------------------------------------}

constructor TSizer.Create(AOwner:TComponent);
var DeskRect:TRect;
begin
SizeSet:=false;
inherited Create(AOwner);
with Owner as TControl do
    begin
    SetSurfaceBounds(ClientWidth,ClientHeight);
    FullW:=Width;
    FullH:=Height;
    end;
Winprocs.GetClientRect(GetDesktopWindow,DeskRect);
DeskSize.X:=DeskRect.Right-DeskRect.Left;
DeskSize.Y:=DeskRect.Bottom-DeskRect.Top;
SizeSet:=true;
end;

procedure TSizer.SetSurfaceBounds(Width,Height:longint);
begin
DesiredWidth:=Width;
DesiredHeight:=Height;
with Owner as TForm do
    begin
    HorzScrollBar.Range:=DesiredWidth;
    VertScrollBar.Range:=DesiredHeight;
    end;
end;

procedure TSizer.Resize;
    procedure ShiftBounds(OldL,MaxW,Size:longint; var NewL,NewW:longint);
    begin
    if OldL>0 then begin
        NewL:=Size-NewW;
        if NewL<0 then begin
            NewW:=NewW+NewL; NewL:=0; end; end;
    end;
var Desk:TRect;
        MaxW,MaxH,OldW,OldH,NewL,NewT,NewW,NewH:longint;
begin
Resizing:=true;
NewW:=0;   NewH:=0;
with Owner as TControl do
    begin

repeat
    MaxW:=DeskSize.X-Left;
    OldW:=NewW;
    NewL:=Left;
    NewW:=Width+(DesiredWidth-ClientWidth);
    if NewW<MinW then NewW:=MinW;
    if NewW>MaxW then ShiftBounds(Left,MaxW,DeskSize.X,NewL,NewW);

    repeat
        MaxH:=DeskSize.Y-Top;
        OldH:=NewH;
        NewT:=Top;
        NewH:=Height+(DesiredHeight-ClientHeight);
        if NewH<MinH then NewH:=MinH;
        if NewH>MaxH then ShiftBounds(Top,MaxH,DeskSize.Y,NewT,NewH);

        SetBounds(NewL,NewT,NewW,NewH);

    until OldH=NewH;
until OldW=NewW;

FullW:=DesiredWidth+Width-ClientWidth;
FullH:=DesiredHeight+Height-ClientHeight;
if FullW<MinW then FullW:=MinW;
if FullH<MinH then FullH:=MinH;

Resizing:=false;
end;
end;

procedure TSizer.WMGetMinMaxInfo(var Msg:TMessage);
begin
with PMinMaxInfo(Msg.lParam)^ do
    begin
    if (not SizeSet) then
        begin
        MinW:=ptMinTrackSize.X;
        MinH:=ptMinTrackSize.Y;
        end
    else if (not Resizing) then
        begin
        ptMaxTrackSize.X:=FullW;
        ptMaxTrackSize.Y:=FullH;
        end;
    end;
end;

procedure TSizer.SetDesiredWidth(NewWidth:longint);
begin
SetSurfaceBounds(NewWidth,DesiredHeight);
Resize;
end;

procedure TSizer.SetDesiredHeight(NewHeight:longint);
begin
SetSurfaceBounds(DesiredWidth,NewHeight);
Resize;
end;

procedure Register;
begin
RegisterComponents('Additional', [TSizer]);
end;

end.